home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-zelk / peekpoke.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-13  |  7.6 KB  |  270 lines
  1. /* peekpoke.c zilla 20sep - Peek/Poke routines:foundations of fstructures
  2.  * Peek/Poke routines are the foundation access routine for fstructs;
  3.  * see fstruct.e.
  4.  * There are two sets of routines:
  5.  * 1) named like farray%peek-int, peek or poke signed or unsigned
  6.  *    (4byte) ints or shorts within an farray.  The offset within the farray
  7.  *    is checked, so these routines are relatively safe.
  8.  *    Char access is not needed because fstructs are based on
  9.  *    'string (byte) farrays, and farray-ref/set can be used directly.
  10.  * >> This set is used for mapping an fstruct onto scheme heap memory
  11.  *    allocated with farray.  Use this type if possible.
  12.  * 2) named like %peek-int, peek or poke signed or unsigned 
  13.  *    (4 byte) ints, shorts, or chars at an arbitrary address.
  14.  * >> This set is used for mapping an fstruct onto memory returned by 
  15.  *    malloc or some other routine; the address looks like an integer
  16.  *    to scheme.
  17.  *
  18.  * The farray routines appear to work (see fstruct.e);
  19.  * The unsafe routines have not been used or tested.
  20.  
  21.     Portions of this file are Copyright (C) 1991 John Lewis
  22.  
  23.     This file is free software; you can redistribute it and/or modify
  24.     it under the terms of the GNU General Public License as published by
  25.     the Free Software Foundation.
  26.  
  27.     This program is distributed in the hope that it will be useful,
  28.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  29.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  30.     GNU General Public License for more details.
  31.  
  32.     You should have received a copy of the GNU General Public License
  33.     along with this program; if not, write to the Free Software
  34.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  35.  */
  36.  
  37. #include <theusual.h>
  38. #include <constants.h>
  39. #include <scheme.h>
  40. #include <assert.h>
  41. #include <zelk.h>
  42.  
  43. /*%%%%%%%%%%%%%%%% peek/poke in an farray %%%%%%%%%%%%%%%%*/
  44.  
  45. static void check_offset P_((int,int,int));
  46.  
  47. /* helper to farray peek/poke */
  48. static void check_offset(off,align,len)
  49.   int off,align,len;
  50. {
  51.   if ((align*off/align) != off)
  52.     Primitive_Error("peek/poke datum is not aligned");
  53.   if ((off < 0) || (off >= len)) Primitive_Error("index out of array");
  54. }
  55.  
  56.  
  57. #define FARRAYPEEKTYPE(NAME,SNAME,TYPE,ALIGN) \
  58. Object NAME(F,Off) \
  59.   Object F,Off; \
  60. {\
  61.   int4 off;\
  62.   Farray *f;\
  63.   char *adr;\
  64.   int size;\
  65.   Error_Tag = SNAME;\
  66.   \
  67.   Check_Type(F,T_Farray);\
  68.   off = Get_Integer(Off);\
  69.   f = FARRAY(F);\
  70.   switch(f->type) {\
  71.     case T_String: size = 1; break;\
  72.     default: size = 4; break;\
  73.   }\
  74.   check_offset(off,ALIGN,f->len * size);\
  75.   adr = (char *)(f->data);\
  76.   adr += off;\
  77.   \
  78.   return Make_Integer( *((TYPE *)adr) );\
  79. }
  80.  
  81.  
  82. #define FARRAY_PEEKINT   P_farray_peekint, "farray%peek-int", 2,2,EVAL,
  83. FARRAYPEEKTYPE(P_farray_peekint,"farray%peek-int", int4, 4)
  84.  
  85. #define FARRAY_PEEKUINT   P_farray_peekuint, "farray%peek-uint", 2,2,EVAL,
  86. FARRAYPEEKTYPE(P_farray_peekuint,"farray%peek-uint", unsigned int4, 4)
  87.  
  88. #define FARRAY_PEEKSHORT  P_farray_peekshort, "farray%peek-short", 2,2,EVAL,
  89. FARRAYPEEKTYPE(P_farray_peekshort,"farray%peek-short", short, 2)
  90.  
  91. #define FARRAY_PEEKUSHORT  P_farray_peekushort, "farray%peek-ushort", 2,2,EVAL,
  92. FARRAYPEEKTYPE(P_farray_peekushort,"farray%peek-ushort", unsigned short, 2)
  93.  
  94.  
  95.  
  96. #define FARRAYPOKETYPE(NAME,SNAME,TYPE,ALIGN) \
  97. Object NAME(F,Off,Value) \
  98.   Object F,Off,Value;\
  99. {\
  100.   int4 off; TYPE val;\
  101.   Farray *f;\
  102.   char *adr;\
  103.   int size;\
  104.   Error_Tag = SNAME ;\
  105. \
  106.   Check_Type(F,T_Farray);\
  107.   off = Get_Integer(Off);\
  108.   val = Get_Integer(Value);\
  109.   f = FARRAY(F);\
  110.   switch(f->type) {\
  111.     case T_String: size = 1; break;\
  112.     default: size = 4; break;\
  113.   }\
  114.   check_offset(off,ALIGN,f->len * size);\
  115. \
  116.   adr = (char *)(f->data);\
  117.   adr += off;\
  118.   *((TYPE *)adr) = val;\
  119.   return Null;\
  120. } /*%poke*/
  121.  
  122.  
  123. #define FARRAY_POKEINT  P_farray_pokeint,"farray%poke-int",3,3,EVAL,
  124. FARRAYPOKETYPE(P_farray_pokeint,"farray%poke-int",int4,4)
  125.  
  126. #define FARRAY_POKEUINT  P_farray_pokeuint,"farray%poke-uint",3,3,EVAL,
  127. FARRAYPOKETYPE(P_farray_pokeuint,"farray%poke-uint",unsigned int4,4)
  128.  
  129. #define FARRAY_POKESHORT  P_farray_pokeshort,"farray%poke-short",3,3,EVAL,
  130. FARRAYPOKETYPE(P_farray_pokeshort,"farray%poke-short",short,2)
  131.  
  132. #define FARRAY_POKEUSHORT  P_farray_pokeushort,"farray%poke-ushort",3,3,EVAL,
  133. FARRAYPOKETYPE(P_farray_pokeushort,"farray%poke-ushort",unsigned short,2)
  134.  
  135. /*%%%%%%%%%%%%%%%% unsafe peek/poke %%%%%%%%%%%%%%%%*/
  136.  
  137. /* helper to unsafe peek/poke */
  138. static void check_align P_((char *,int));
  139. static void check_align(off,align)
  140.   char *off;
  141.   int align;
  142. {
  143.   int4 ioff = (int4)off;
  144.   if ((align*ioff/align) != ioff)
  145.     Primitive_Error("peek/poke datum is not aligned");
  146. }
  147.  
  148. #define UNSAFEPEEKTYPE(NAME,SNAME,TYPE,ALIGN) \
  149. Object NAME(Addr,Off) \
  150.   Object Addr,Off; \
  151. {\
  152.   char *addr; int4 off;\
  153.   Error_Tag = SNAME;\
  154. \
  155.   addr = (char *)Get_Integer(Addr);\
  156.   off = Get_Integer(Off);\
  157.   addr += off;\
  158.   check_align((char *)addr,ALIGN);\
  159. \
  160.   return Make_Integer(*((TYPE *)addr));\
  161. }
  162.  
  163.  
  164. #define UNSAFE_PEEKINT   P_unsafe_peekint, "%peek-int", 2,2,EVAL,
  165. UNSAFEPEEKTYPE(P_unsafe_peekint,"%peek-int", int4, 4)
  166.  
  167. #define UNSAFE_PEEKUINT   P_unsafe_peekuint, "%peek-uint", 2,2,EVAL,
  168. UNSAFEPEEKTYPE(P_unsafe_peekuint,"%peek-uint", unsigned int4, 4)
  169.  
  170. #define UNSAFE_PEEKSHORT  P_unsafe_peekshort, "%peek-short", 2,2,EVAL,
  171. UNSAFEPEEKTYPE(P_unsafe_peekshort,"%peek-short", short, 2)
  172.  
  173. #define UNSAFE_PEEKUSHORT  P_unsafe_peekushort, "%peek-ushort", 2,2,EVAL,
  174. UNSAFEPEEKTYPE(P_unsafe_peekushort,"%peek-ushort", unsigned short, 2)
  175.  
  176. #define UNSAFE_PEEKCHAR  P_unsafe_peekchar, "%peek-char", 2,2,EVAL,
  177. UNSAFEPEEKTYPE(P_unsafe_peekchar,"%peek-char", char, 1)
  178.  
  179. #define UNSAFE_PEEKUCHAR  P_unsafe_peekuchar, "%peek-uchar", 2,2,EVAL,
  180. UNSAFEPEEKTYPE(P_unsafe_peekuchar,"%peek-uchar", unsigned char, 1)
  181.  
  182.  
  183.  
  184. #define UNSAFEPOKETYPE(NAME,SNAME,TYPE,ALIGN) \
  185. Object NAME(Addr,Off,Value) \
  186. Object Addr,Off,Value;\
  187. {\
  188.   int4 off; TYPE val;\
  189.   char *addr;\
  190.   Error_Tag = SNAME ;\
  191. \
  192.   addr = (char *)Get_Integer(Addr);\
  193.   off = Get_Integer(Off);\
  194.   addr += off;\
  195.   check_align((char *)addr,ALIGN);\
  196.   val = Get_Integer(Value);\
  197. \
  198.   *((TYPE *)addr) = val;\
  199.   return Null;\
  200. } /*unsafe%poke*/
  201.  
  202.  
  203. #define UNSAFE_POKEINT   P_unsafe_pokeint, "%poke-int", 3,3,EVAL,
  204. UNSAFEPOKETYPE(P_unsafe_pokeint,"%poke-int", int4, 4)
  205.  
  206. #define UNSAFE_POKEUINT   P_unsafe_pokeuint, "%poke-uint", 3,3,EVAL,
  207. UNSAFEPOKETYPE(P_unsafe_pokeuint,"%poke-uint", unsigned int4, 4)
  208.  
  209. #define UNSAFE_POKESHORT  P_unsafe_pokeshort, "%poke-short", 3,3,EVAL,
  210. UNSAFEPOKETYPE(P_unsafe_pokeshort,"%poke-short", short, 2)
  211.  
  212. #define UNSAFE_POKEUSHORT  P_unsafe_pokeushort, "%poke-ushort", 3,3,EVAL,
  213. UNSAFEPOKETYPE(P_unsafe_pokeushort,"%poke-ushort", unsigned short, 2)
  214.  
  215. #define UNSAFE_POKECHAR  P_unsafe_pokechar, "%poke-char", 3,3,EVAL,
  216. UNSAFEPOKETYPE(P_unsafe_pokechar,"%poke-char", char, 1)
  217.  
  218. #define UNSAFE_POKEUCHAR  P_unsafe_pokeuchar, "%poke-uchar", 3,3,EVAL,
  219. UNSAFEPOKETYPE(P_unsafe_pokeuchar,"%poke-uchar", unsigned char, 1)
  220.  
  221.  
  222. /*%%%% these should go into zelk.c if fstructs work out %%%%*/
  223.  
  224. #include <sys/stat.h>
  225. #define LINK_STAT  { "os-stat",  (vfunction *)stat, "SARI" },
  226.  
  227. static struct fordef fortab[] = {
  228.   LINK_STAT
  229.   {(char *)0, (vfunction *)0, (char *)0}
  230. };
  231.  
  232.  
  233. /*%%%%%%%%%%%%%%%% link %%%%%%%%%%%%%%%%*/
  234.  
  235. static struct primdef Prims[] = {
  236.   FARRAY_PEEKINT
  237.   FARRAY_PEEKUINT
  238.   FARRAY_POKEINT
  239.   FARRAY_POKEUINT
  240.  
  241.   FARRAY_PEEKSHORT
  242.   FARRAY_PEEKUSHORT
  243.   FARRAY_POKESHORT
  244.   FARRAY_POKEUSHORT
  245.  
  246.   UNSAFE_PEEKINT
  247.   UNSAFE_PEEKUINT
  248.   UNSAFE_PEEKSHORT
  249.   UNSAFE_PEEKUSHORT
  250.   UNSAFE_PEEKCHAR
  251.   UNSAFE_PEEKUCHAR
  252.  
  253.   UNSAFE_POKEINT
  254.   UNSAFE_POKEUINT
  255.   UNSAFE_POKESHORT
  256.   UNSAFE_POKEUSHORT
  257.   UNSAFE_POKECHAR
  258.   UNSAFE_POKEUCHAR
  259.  
  260.   (Object (*)())0, (char *)0, 0,0,EVAL
  261. };
  262.  
  263.  
  264. void Init_peekpoke()
  265. {
  266.   ZLprimdeftab(Prims);
  267.   Define_Fortab(fortab);
  268.   P_Provide(Intern("pokepoke.o"));
  269. } /*init*/
  270.